home *** CD-ROM | disk | FTP | other *** search
/ MacGames Sampler / PHT MacGames Bundle.iso / MacSource Folder / Samples from the CD / Editors / emacs / Emacs-1.14b1 / lisp / think-c / tc-receive.el < prev    next >
Encoding:
Text File  |  1994-03-23  |  26.8 KB  |  725 lines  |  [TEXT/EMAC]
  1. ;;;
  2. ;;; Implementation of the THINK Editor suite
  3. ;;;
  4. ;;; This file is part of the Macintosh port of GNU Emacs.
  5. ;;; Copyright (C) 1993 Marc Parmet.
  6. ;;;
  7.  
  8.  
  9. ; Events Sent From THINK To The Editor
  10. ; ====================================
  11. ; 
  12. ; Open Document --- THINK sends this event when it wants the editor to open a text file.
  13. ; 
  14. ; Event Class:    kCoreEventClass
  15. ; Event ID:        kAEOpenDocuments
  16. ; Parameters:    
  17. ;     
  18. ;     keyDirectObject (typeFSS, required)
  19. ;         The file to open.
  20. ;         
  21. ;     keyAEPosition (typeChar, optional)
  22. ;         A struct which may specify a selection range and/or accompanying error message.
  23. ;         The struct is defined as follows:
  24. ;                 
  25. ;         struct {                            
  26. ;             short showMsg;        //    if nonzero and line >= 0, display errmsg in an Alert.    
  27. ;             short line;            //    The line to be selected.
  28. ;             long start;            //    The start of the selection range (ignore if line>=0).
  29. ;             long end;            //    The end of the selection range (ignore if line>=0).
  30. ;             StringHandle errmsg;    //    The error message to display.
  31. ;             long    fileModDate;    //    The modification time of the disk file.
  32. ;         };
  33. ; 
  34. ;         If line, start, and end are all negative, there is no selection range specified.
  35. ;         Otherwise, the selection range indicated by line or start/end should be selected
  36. ;         and the edit window should be scrolled to show this selection.
  37. ;         
  38. ;         If line>=0 and showMsg is nonzero, the error message at *errmsg should be 
  39. ;         displayed immediately after selecting and scrolling to the line.
  40.  
  41. (c:defstruct tc:struct-position ((short showMsg)
  42.                                  (short line)
  43.                                  (long start)
  44.                                  (long end)
  45.                                  (long errMsg)
  46.                                  (long fileModDate)))
  47.                                      
  48. ;;; This is called by the general OpenDocuments handler, which has special knowledge
  49. ;;; of this routine.
  50. (defun tc:parse-position-record (event)
  51.   (if tc:debug-trace (DebugStr "Emacs TPM code got ODOC event"))
  52.   (condition-case errmsg
  53.       (catch 'panic
  54.         (let* ((returnedType (make-string 4 0))
  55.                (data (make-string (c:sizeof 'tc:struct-position) 0))
  56.                (actualSize (make-string 4 0))
  57.                (junk (throw-err 
  58.                       (AEGetParamPtr event keyAEPosition typeChar returnedType
  59.                                      data (length data) actualSize)))
  60.                (showMsg (c:slotref 'tc:struct-position data 'showMsg))
  61.                (line (1+ (c:slotref 'tc:struct-position data 'line)))
  62.                (start (1+ (c:slotref 'tc:struct-position data 'start)))
  63.                (end (1+ (c:slotref 'tc:struct-position data 'end)))
  64.                (errMsg-handle (c:slotref 'tc:struct-position data 'errMsg)))
  65.           (setq tc:opened-from-TPM t)
  66.           (if (>= line 1)
  67.               (goto-line line)
  68.             (if (and (>= start 1) (>= end 1))
  69.                 (progn
  70.                   (goto-char start)
  71.                   (set-mark end)
  72.                   (if (not (input-pending-p))
  73.                       (progn
  74.                         (sit-for 1)
  75.                         (goto-char end)
  76.                         (if (not (input-pending-p))
  77.                             (sit-for 1))
  78.                         (goto-char start))))))
  79.           (if (and (not (zerop showMsg))
  80.                    (>= line 0))
  81.               (progn
  82.                 (HLock errMsg-handle)
  83.                 (let ((errMsg-ptr (deref errMsg-handle)))
  84.                   (message (concat "TPM message: "
  85.                                    (extract-internal errMsg-ptr 0 'pascal-string))))
  86.                 (HUnlock errMsg-handle)))
  87.           (bring-emacs-to-the-front)))
  88.     (error (if tc:debug-failures (DebugStr "Couldn't complete ODOC"))
  89.            errAEEventNotHandled)))
  90.  
  91. ; -----------------------------------------------------------------------
  92. ; -----------------------------------------------------------------------
  93. ;
  94. ; Modified --- THINK sends the Modified event when it needs to know which files have been 
  95. ;              modified and when they've been modified.  Send back a list of the following 
  96. ;              structs as the direct object of the reply event (one struct for each open 
  97. ;              file that has been modified).
  98. ;         
  99. ; Event Class:    'KAHL'
  100. ; Event ID:        'MOD '
  101. ; Parameters:        none
  102. ; 
  103. ;     struct {
  104. ;         FSSpec     fss;    //    the file spec
  105. ;         long    when;    //    the time the file was last modified
  106. ;         short    saved;    //    ??? when replying to the Modified event, set 'saved' to zero
  107. ;     };
  108.  
  109. (AEInstallEventHandler "KAHL" "MOD " 'tc:do-modified-event 0 0)
  110.  
  111. (c:defstruct tc:struct-modified ((FSSpec fss)
  112.                                  (long when)
  113.                                  (short saved)))
  114.  
  115. (defun tc:do-modified-event (event reply refCon)
  116.   (if tc:debug-trace (DebugStr "Emacs TPM code got MOD event"))
  117.   (condition-case errmsg
  118.       (catch 'panic
  119.         (let* ((file-list (tc:relevant-buffers))
  120.                (ae-list (make-string sizeof-AEDescList 0))
  121.                now
  122.                spec
  123.                (modified-record (make-string (c:sizeof 'tc:struct-modified) 0)))
  124. ;(DebugStr "In do-mod, file-list is " file-list)
  125.           (throw-err (AECreateList 0 0 0 ae-list))
  126.           (GetDateTime now)
  127.           (while file-list
  128.             (if (and (nth 1 (car file-list))  ; File name associated with buffer
  129.                      (nth 2 (car file-list))) ; Buffer modified since last save
  130.                 (progn
  131. ;(DebugStr "Looking at " (nth 1 (car file-list)))
  132.                   (throw-err (unix-filename-to-FSSpec (nth 1 (car file-list)) spec))
  133.                   (c:slotset 'tc:struct-modified modified-record 'fss spec)
  134.                   (c:slotset 'tc:struct-modified modified-record 'when (- now 5))
  135.                   (c:slotset 'tc:struct-modified modified-record 'saved 0)
  136.                   (throw-err (AEPutPtr ae-list 0 typeChar modified-record
  137.                                        (length modified-record)))))
  138.             (setq file-list (cdr file-list)))
  139. ;(DebugStr "In do-mod, adding direct obj")
  140.           (throw-err (AEPutParamDesc reply keyDirectObject ae-list))
  141.           noErr))
  142.     (error (if tc:debug-failures (DebugStr "Couldn't complete MOD"))
  143.            errAEEventNotHandled)))
  144.  
  145. ; -----------------------------------------------------------------------
  146. ; -----------------------------------------------------------------------
  147. ;
  148. ; Get Text --- THINK sends this event when it needs to get a current copy of the file
  149. ;              (for compilation or debugging).
  150. ;         
  151. ; Event Class:    'KAHL'
  152. ; Event ID:        'GTTX'
  153. ; Parameters:
  154. ; 
  155. ;     keyDirectObject (typeChar, required)
  156. ;         A struct which specifies the file THINK is looking for, and where the editor
  157. ;         should return the requested information.
  158. ;         
  159. ;         struct {
  160. ;             FSSpec fss;        //    the file THINK is looking for
  161. ;             Handle textH;    //    where to return the file's text
  162. ;             FTRec *ftp;        //    where to return the font/tabs info 
  163. ;                             //    (ftp == 0 if compiling).  This info is used to format
  164. ;                             //    the file's display in the Debugger's Source window.
  165. ;             long *modified;    //    where to return the time-modified of the file
  166. ;         };
  167.  
  168. (AEInstallEventHandler "KAHL" "GTTX" 'tc:do-gttx-event 0 0)
  169.  
  170. (c:defstruct tc:struct-gttx ((FSSpec fss)
  171.                              (long textH)
  172.                              (long ftp)
  173.                              (long modified)))
  174.  
  175. (c:defstruct tc:struct-FTRec ((short fontNum)
  176.                               (short fontSize)
  177.                               (short spaceWidth)
  178.                               (short tabStops)))
  179.  
  180. (defun tc:do-gttx-event (event reply refCon)
  181.   (if tc:debug-trace (DebugStr "Emacs TPM code got GTTX event"))
  182.   (condition-case errmsg
  183.       (catch 'panic
  184.         (let* ((returnedType (make-string 4 0))
  185.                (actualSize (make-string 4 0))
  186.                (gttx-msg (make-string (c:sizeof 'tc:struct-gttx) 0))
  187.                now
  188.                (junk1 (throw-err
  189.                       (AEGetParamPtr event keyDirectObject typeChar returnedType
  190.                                      gttx-msg (c:sizeof 'tc:struct-gttx) actualSize)))
  191.                (spec (c:slotref 'tc:struct-gttx gttx-msg 'fss))
  192.                (textH (c:slotref 'tc:struct-gttx gttx-msg 'textH))
  193.                (ftp (c:slotref 'tc:struct-gttx gttx-msg 'ftp))
  194.                (modified (c:slotref 'tc:struct-gttx gttx-msg 'modified))
  195.                (filename (FSSpec-to-unix-filename spec))
  196.                (junk2 (if (integerp filename) (throw 'panic filename)))
  197.                (old-buffer (current-buffer))
  198.                (buffer (get-file-buffer filename)))
  199.           (if (not buffer) (throw 'panic errAEEventNotHandled))
  200.           (set-buffer buffer)
  201.           (SetHandleSize textH (buffer-size))
  202.           (if (not (zerop (MemError))) (throw 'panic (MemError)))
  203.           (if tc:debug-trace (DebugStr "Moving " (buffer-size) " bytes to " textH))
  204.           (subst-char-in-region (point-min) (point-max) 10 13 t)
  205.           (HLock textH)
  206.           (BlockMove (buffer-string) (StripAddress (deref textH)) (buffer-size))
  207.           (HUnlock textH)
  208.           (subst-char-in-region (point-min) (point-max) 13 10 t)
  209.           
  210.           (if (not (zerop ftp))
  211.               (progn
  212.                 (if tc:debug-trace (DebugStr "Filling in ftp record"))
  213.                 (tc:send-mkup buffer)
  214.                 (if (not (zerop (tc:lineOffsets)))
  215.                     (progn (DisposHandle (tc:lineOffsets)) (setf-tc:lineOffsets 0)))
  216.                 (remake-lineOffsets)
  217.                 ;;; Need more accurate values here.
  218.                 (c:slotset 'tc:struct-FTRec ftp 'fontNum 4)
  219.                 (c:slotset 'tc:struct-FTRec ftp 'fontSize 9)
  220.                 (c:slotset 'tc:struct-FTRec ftp 'spaceWidth 6)
  221.                 (c:slotset 'tc:struct-FTRec ftp 'tabStops tab-width)))
  222.           
  223.           (GetDateTime now)
  224.           (encode-internal modified 0 'long (if (buffer-modified-p) (- now 5) 0))
  225.           (set-buffer old-buffer)
  226.           noErr))
  227.     (error (if tc:debug-failures (DebugStr "Couldn't complete GTTX"))
  228.            errAEEventNotHandled)))
  229.  
  230. ; -----------------------------------------------------------------------
  231. ; -----------------------------------------------------------------------
  232. ;
  233. ; Get Debugger State --- THINK sends this event when it needs to get the current Debugger 
  234. ;                        state information for the file (when debugging).  
  235. ; 
  236. ; Event Class:    'KAHL'
  237. ; Event ID:        'GTDS'
  238. ; Parameters:
  239. ; 
  240. ;     keyDirectObject (typeChar, required)
  241. ;         A struct which indicates the file THINK is looking for, the type of information
  242. ;         THINK wants, and where the editor should return the requested information.
  243. ;         Refer to the MiniEdit source code to see how to access and return the data.
  244. ; 
  245. ;         typedef struct {
  246. ;             short             fileNum;        /*    for THINK's internal use    */
  247. ;             long            rsrcType;        /*    'BKPT' or 'DTVU'            */
  248. ;             short             rsrcID;            /*    ID of desired resource        */
  249. ;             void            *rsrcH;            /*    Handle to resource data        */
  250. ;         } getStateMsg;
  251. ; 
  252. ;         struct {
  253. ;             FSSpec fss;            //    The file of interest
  254. ;             getStateMsg *msg;
  255. ;         };
  256.  
  257. (c:defstruct tc:struct-fssPlus ((FSSpec fss)
  258.                                 (long getStateMsg)))
  259.  
  260. (c:defstruct tc:struct-getStateMsg ((short fileNum)
  261.                                     ((array char 4) rsrcType)
  262.                                     (short rsrcID)
  263.                                     (long rsrcH)))
  264.  
  265. (AEInstallEventHandler "KAHL" "GTDS" 'tc:do-gtds-event 0 0)
  266.  
  267. (defun tc:do-gtds-event (event reply refCon)
  268.   (if tc:debug-trace (DebugStr "Emacs TPM code got GTDS event"))
  269.   (condition-case errmsg
  270.       (catch 'panic
  271.         (let* ((resultType (make-string 4 0))
  272.                (data (make-string (c:sizeof 'tc:struct-fssPlus) 0))
  273.                (actualSize (make-string 4 0))
  274.                (junk (throw-err (AEGetParamPtr event keyDirectObject typeChar resultType
  275.                                                data (length data) actualSize)))
  276.                (spec (c:slotref 'tc:struct-fssPlus data 'fss))
  277.                (msg (c:slotref 'tc:struct-fssPlus data 'getStateMsg))
  278.                (rsrcType (c:slotref 'tc:struct-getStateMsg msg 'rsrcType))
  279.                (rsrcID (c:slotref 'tc:struct-getStateMsg msg 'rsrcID))
  280.                (filename (FSSpec-to-unix-filename spec))
  281.                (old-buffer (current-buffer))
  282.                (buffer (get-file-buffer filename)))
  283.           (if (not buffer) (throw 'panic errAEEventNotHandled))
  284.           (if tc:debug-trace (DebugStr "Resource type is " rsrcType " " rsrcID))
  285.           (set-buffer buffer)
  286.           (if (not tc:have-TPM-data) (throw 'panic errAEEventNotHandled))
  287.           (let ((dataHandle
  288.                  (cond
  289.                   ((equal rsrcType "DTVU")
  290.                    (find-rsrc (tc:dataviews) (tc:dtvuIDs) (tc:dtvuSizes)))
  291.                   ((equal rsrcType "BKPT")
  292.                    (find-rsrc (tc:breakpoints) (tc:bkptIDs) (tc:bkptSizes)))
  293.                   (t
  294.                    (throw 'panic errAEEventNotHandled)))))
  295.             (set-buffer old-buffer)
  296.             (c:slotset 'tc:struct-getStateMsg msg 'rsrcH dataHandle)
  297.             noErr)))
  298.     (error (if tc:debug-failures (DebugStr "Couldn't complete GTDS"))
  299.            errAEEventNotHandled)))
  300.  
  301. (defun find-rsrc (data IDs sizes)
  302.   (if (or (zerop data) (zerop IDs) (zerop sizes))
  303.       (throw 'panic errAEEventNotHandled))
  304.   (let* ((numIDs (/ (GetHandleSize IDs) (c:sizeof 'long)))
  305.          (rsrcIndex (lookup-rsrc-id IDs numIDs rsrcID))
  306.          (junk (if (not rsrcIndex) (throw 'panic errAEEventNotHandled)))
  307.          (thisSize (extract-internal (deref sizes) (* (c:sizeof 'long) rsrcIndex) 'long))
  308.          (offset (sum-sizes sizes rsrcIndex))
  309.          (dataHandle (NewHandle thisSize))
  310.          (err (MemError)))
  311.     (if (not (zerop err)) (throw 'panic err))
  312.     (HLock dataHandle)
  313.     (BlockMove (+ (deref data) offset) (deref dataHandle) thisSize)
  314.     (HUnlock dataHandle)
  315.     dataHandle))
  316.  
  317. (defun sum-sizes (size-list target-index)
  318.   (let ((i 0)
  319.         (sum 0))
  320.     (while (< i target-index)
  321.       (setq sum (+ sum (extract-internal (deref size-list) (* (c:sizeof 'long) i) 'long)))
  322.       (setq i (1+ i)))
  323.     sum))
  324.  
  325. (defun lookup-rsrc-id (id-list numIDs targetID)
  326.   (let ((i 0)
  327.         (result nil))
  328.     (while (< i numIDs)
  329.       (let ((thisID (extract-internal (deref id-list) (* (c:sizeof 'long) i) 'long)))
  330.         (if tc:debug-trace (DebugStr "Comparing " thisID " and " targetID))
  331.         (if (= thisID targetID)
  332.             (progn
  333.               (setq result i)
  334.               (setq i numIDs))
  335.           (setq i (1+ i)))))
  336.     result))
  337.  
  338. ; -----------------------------------------------------------------------
  339. ; -----------------------------------------------------------------------
  340. ;
  341. ; Put Debugger State --- THINK sends this event when it needs to replace the Debugger state
  342. ;                        info for a file (when the THINK Debugger saves its current state).
  343. ;                        To respond to this event, the editor returns pointers to its 
  344. ;                        Debugger state info Handles (among other things) in the struct 
  345. ;                        type defined below.
  346. ; 
  347. ; Event Class:    'KAHL'
  348. ; Event ID:        'PTDS'
  349. ; Parameters:
  350. ;     
  351. ;     keyDirectObject (typeChar, required)
  352. ;         A struct which indicates the file THINK is looking for, and where the editor
  353. ;         should return the requested information.  See the MiniEdit source code for more
  354. ;         details.
  355. ;     
  356. ;         struct {
  357. ;             FSSpec     fss;
  358. ;             long    ****pBkptIDs;
  359. ;             long    ****pDtvuIDs;
  360. ;             long    ****pBkptSizes;
  361. ;             long    ****pDtvuSizes;
  362. ;             Handle    **pMarkers;
  363. ;             Handle    **pBreakpoints;
  364. ;             Handle    **pDataviews;
  365. ;             short    ****pLineOffsets;
  366. ;             long     (**GetCharPos)(TEHandle, long);
  367. ;             short    (**GetLineNum)(TEHandle, long, long*);
  368. ;             long    *oldSelStart, *oldSelEnd, *oldTextLength, 
  369. ;                     *oldLineStart, *oldLineEnd, *oldNumLines,
  370. ;                     *newTextLength, *newNumLines, *newSelEnd,
  371. ;                     *refcon;
  372. ;         };
  373.  
  374. (c:defstruct tc:struct-ptds ((FSSpec fss)
  375.                              (long pBkptIDs)
  376.                              (long pDtvuIDs)
  377.                              (long pBkptSizes)
  378.                              (long pDtvuSizes)
  379.                              (long pMarkers)
  380.                              (long pBreakpoints)
  381.                              (long pDataviews)
  382.                              (long pLineOffsets)
  383.                              (long GetCharPos)
  384.                              (long GetLineNum)
  385.                              (long oldSelStart)
  386.                              (long oldSelEnd)
  387.                              (long oldTextLen)
  388.                              (long oldLineStart)
  389.                              (long oldLineEnd)
  390.                              (long oldNumLines)
  391.                              (long newTextLen)
  392.                              (long newNumLines)
  393.                              (long newSelEnd)
  394.                              (unsigned-long refCon)))
  395.  
  396. (AEInstallEventHandler "KAHL" "PTDS" 'tc:do-ptds-event 0 0)
  397.  
  398. (defun tc:do-ptds-event (event reply refCon)
  399.   (if tc:debug-trace (DebugStr "Emacs TPM code got PTDS event"))
  400.   (condition-case errmsg
  401.       (catch 'panic
  402.         (let* ((resultType (make-string 4 0))
  403.                (data (make-string (c:sizeof 'tc:struct-ptds) 0))
  404.                (actualSize (make-string 4 0))
  405.                (junk (throw-err (AEGetParamPtr event keyDirectObject typeChar resultType
  406.                                                data (length data) actualSize)))
  407.                (spec (c:slotref 'tc:struct-ptds data 'fss))
  408.                (filename (FSSpec-to-unix-filename spec))
  409.                (old-buffer (current-buffer))
  410.                (buffer (get-file-buffer filename)))
  411.           (if tc:debug-trace (DebugStr "ptds data is at " (string-data data)
  412.                                        ", buffer is " buffer))
  413.           (if (not buffer) (throw 'panic errAEEventNotHandled))
  414.           (set-buffer buffer)
  415.           (if (zerop tc:addressables) (throw 'panic errAEEventNotHandled))
  416.  
  417.           (mapcar (function (lambda (x)
  418.                               (encode-internal 
  419.                                (c:slotref 'tc:struct-ptds data (car x))
  420.                                0 'unsigned-long (cdr x))))
  421.                   (list
  422.                    (cons 'pBkptIDs (+ tc:addressables tc:bkptIDs-offset))
  423.                    (cons 'pDtvuIDs (+ tc:addressables tc:dtvuIDs-offset))
  424.                    (cons 'pBkptSizes (+ tc:addressables tc:bkptSizes-offset))
  425.                    (cons 'pDtvuSizes (+ tc:addressables tc:dtvuSizes-offset))
  426.                    (cons 'pMarkers (+ tc:addressables tc:markers-offset))
  427.                    (cons 'pBreakpoints (+ tc:addressables tc:breakpoints-offset))
  428.                    (cons 'pDataviews (+ tc:addressables tc:dataviews-offset))
  429.                    (cons 'pLineOffsets (+ tc:addressables tc:lineOffsets-offset))
  430.                    (cons 'GetCharPos tc:GetCharPos)
  431.                    (cons 'GetLineNum tc:GetLineNum)
  432.                    (cons 'oldSelStart tc:oldSelStart)
  433.                    (cons 'oldSelEnd tc:oldSelEnd)
  434.                    (cons 'oldTextLen tc:oldTextLen)
  435.                    (cons 'oldLineStart tc:oldLineStart)
  436.                    (cons 'oldLineEnd tc:oldLineEnd)
  437.                    (cons 'oldNumLines tc:oldNumLines)
  438.                    (cons 'newTextLen (tc:textLen))
  439.                    (cons 'newNumLines (tc:numLines))
  440.                    (cons 'newSelEnd (tc:selEnd))
  441.                    (cons 'refCon buffer)))
  442.           (set-buffer old-buffer)
  443.           noErr))
  444.     (error (if tc:debug-failures (DebugStr "Couldn't complete PTDS"))
  445.            errAEEventNotHandled)))
  446.  
  447. ; -----------------------------------------------------------------------
  448. ; -----------------------------------------------------------------------
  449. ;
  450. ; Window Search --- THINK sends this event whenever it needs to know whether the editor
  451. ;                   has a specific file open for editing.  If the file is open, send back 
  452. ;                   the file's modified time;  otherwise, return fnfErr (file not found).
  453. ; 
  454. ; Event Class:    'KAHL'
  455. ; Event ID:        'SRCH'
  456. ; Parameters:
  457. ; 
  458. ;     keyDirectObject (typeChar, required)
  459. ;         A struct which indicates the file THINK is looking for, and where the editor
  460. ;         should return the file's modified time.  See the MiniEdit source code for more
  461. ;         details.
  462. ; 
  463. ;         struct {
  464. ;             FSSpec fss;            //    The file THINK is looking for.
  465. ;             long *modified;        //    Where to return the file's modified time.
  466. ;         };
  467.  
  468. (AEInstallEventHandler "KAHL" "SRCH" 'tc:do-srch-event 0 0)
  469.  
  470. (c:defstruct tc:struct-srch ((FSSpec fss)
  471.                              (long modified)))
  472.  
  473. (defun tc:do-srch-event (event reply refCon)
  474.   (if tc:debug-trace (DebugStr "Emacs TPM code got SRCH event"))
  475.   (condition-case errmsg
  476.       (catch 'panic
  477.         (let* ((returnedType (make-string 4 0))
  478.                (actualSize (make-string 4 0))
  479.                (srch-record (make-string (c:sizeof 'tc:struct-srch) 0))
  480.                now
  481.                (junk (throw-err
  482.                       (AEGetParamPtr event keyDirectObject typeChar returnedType
  483.                                      srch-record (c:sizeof 'tc:struct-srch) actualSize)))
  484.                (spec (c:slotref 'tc:struct-srch srch-record 'fss))
  485.                (modified (c:slotref 'tc:struct-srch srch-record 'modified))
  486.                (filename (FSSpec-to-unix-filename spec))
  487.                (buffer (get-file-buffer filename)))
  488.           (if (not buffer) (throw 'panic fnfErr))
  489.           (set-buffer buffer)
  490.           (GetDateTime now)
  491.           (encode-internal modified 0 'long (if (buffer-modified-p) (- now 5) 0))
  492.           noErr))
  493.     (error (if tc:debug-failures (DebugStr "Couldn't complete SRCH"))
  494.            errAEEventNotHandled)))
  495.  
  496. ; -----------------------------------------------------------------------
  497. ; -----------------------------------------------------------------------
  498. ;
  499. ; Marker Update --- THINK sends this event when it needs the editor to ensure that the 
  500. ;                   debugger state information is up-to-date.  Return the marker 
  501. ;                   information for EACH open file in an AEDescList composed of the 
  502. ;                   following structs.  See the MiniEdit code for details.
  503. ; 
  504. ; Event Class:    'KAHL'
  505. ; Event ID:        'MKUP'
  506. ; Parameters:        none
  507. ; 
  508. ;     struct {
  509. ;         Handle     markers, breakpoints, dataviews, lineOffsets, dtvuIDs;
  510. ;         long    oldSelStart, oldSelEnd, oldTextLength, 
  511. ;                 oldLineStart, oldLineEnd, oldNumLines,
  512. ;                 newTextLength, newNumLines, newSelEnd;
  513. ;         long     refcon;            
  514. ;     };
  515.  
  516. (c:defstruct tc:struct-mkup ((long markers)
  517.                              (long breakpoints)
  518.                              (long dataviews)
  519.                              (long lineOffsets)
  520.                              (long dtvuIDs)
  521.                              (long oldSelStart)
  522.                              (long oldSelEnd)
  523.                              (long oldTextLen)
  524.                              (long oldLineStart)
  525.                              (long oldLineEnd)
  526.                              (long oldNumLines)
  527.                              (long newTextLen)
  528.                              (long newNumLines)
  529.                              (long newSelEnd)
  530.                              (unsigned-long refCon)))
  531.  
  532. (defun make-mkup (buffer)
  533.   (let ((old-buffer (current-buffer))
  534.         (mkup (make-string (c:sizeof 'tc:struct-mkup) 0)))
  535.     (set-buffer buffer)
  536.     (if (not tc:have-TPM-data)
  537.         (progn
  538.           (set-buffer old-buffer)
  539.           nil)
  540.       (c:slotset 'tc:struct-mkup mkup 'markers (tc:markers))
  541.       (c:slotset 'tc:struct-mkup mkup 'breakpoints (tc:breakpoints))
  542.       (c:slotset 'tc:struct-mkup mkup 'dataviews (tc:dataviews))
  543.       (c:slotset 'tc:struct-mkup mkup 'lineOffsets (tc:lineOffsets))
  544.       (c:slotset 'tc:struct-mkup mkup 'dtvuIDs (tc:dtvuIDs))
  545.       (c:slotset 'tc:struct-mkup mkup 'oldSelStart tc:oldSelStart)
  546.       (c:slotset 'tc:struct-mkup mkup 'oldSelEnd tc:oldSelEnd)
  547.       (c:slotset 'tc:struct-mkup mkup 'oldTextLen tc:oldTextLen)
  548.       (c:slotset 'tc:struct-mkup mkup 'oldLineStart tc:oldLineStart)
  549.       (c:slotset 'tc:struct-mkup mkup 'oldLineEnd tc:oldLineEnd)
  550.       (c:slotset 'tc:struct-mkup mkup 'oldNumLines tc:oldNumLines)
  551.       (c:slotset 'tc:struct-mkup mkup 'newTextLen (tc:textLen))
  552.       (c:slotset 'tc:struct-mkup mkup 'newNumLines (tc:numLines))
  553.       (c:slotset 'tc:struct-mkup mkup 'newSelEnd (tc:selEnd))
  554.       (c:slotset 'tc:struct-mkup mkup 'refCon buffer)
  555.       (set-buffer old-buffer)
  556.       mkup)))
  557.  
  558. (AEInstallEventHandler "KAHL" "MKUP" 'tc:do-mkup-event 0 0)
  559.  
  560. (defun tc:do-mkup-event (event reply refCon)
  561.   (if tc:debug-trace (DebugStr "Emacs TPM code got MKUP event"))
  562.   (condition-case errmsg
  563.       (catch 'panic
  564.         (let* ((old-buffer (current-buffer))
  565.                (mkup-list (make-string sizeof-AEDescList 0))
  566.                (callback-data (encode-long-integer tc:GetLineNum)))
  567.           (throw-err (AEPutParamPtr reply "CLBK" typeChar callback-data (c:sizeof 'long)))
  568.           (throw-err (AECreateList 0 0 0 mkup-list))
  569.           (mapcar (function
  570.                    (lambda (x)
  571.                      (set-buffer (car x))
  572.                      (let ((mkup (make-mkup (car x))))
  573.                        (if mkup
  574.                            (throw-err
  575.                             (AEPutPtr mkup-list 0 typeChar mkup (length mkup)))))))
  576.                   (tc:relevant-buffers))
  577.           (throw-err (AEPutParamDesc reply keyDirectObject mkup-list))
  578.           (AEDisposeDesc mkup-list)
  579.           (set-buffer old-buffer)
  580.           noErr))
  581.     (error (DebugStr "Couldn't complete MKUP")
  582.            errAEEventNotHandled)))
  583.  
  584. ; -----------------------------------------------------------------------
  585. ; -----------------------------------------------------------------------
  586. ;
  587. ; Make LineOffsets --- THINK sends this event when it needs the editor to create a new
  588. ;                      lineOffsets array for EACH open file.
  589. ; 
  590. ; Event Class:    'KAHL'
  591. ; Event ID:        'OFST'
  592. ; Parameters:        none
  593.  
  594. ;;    long nLines = GetNumLines(TEH);    //    Create a new lineOffsets array for THINK
  595. ;;    lineOffsets = (short**) NewHandleClear(sizeof(short) * (nLines+1));
  596. ;;    (*lineOffsets)[nLines] = 0x7FFF - nLines;
  597. ;;    return(noErr);
  598.  
  599. (AEInstallEventHandler "KAHL" "OFST" 'tc:do-ofst-event 0 0)
  600.  
  601. (defun tc:do-ofst-event (event reply refCon)
  602.   (if tc:debug-trace (DebugStr "Emacs TPM code got OFST event"))
  603.   (condition-case errmsg
  604.       (let* ((old-buffer (current-buffer)))
  605.         (mapcar (function (lambda (x) (set-buffer (car x)) (remake-lineOffsets)))
  606.                 (tc:relevant-buffers))
  607.         (set-buffer old-buffer)
  608.         noErr)
  609.     (error (if tc:debug-failures (DebugStr "Couldn't complete OFST"))
  610.            errAEEventNotHandled)))
  611.  
  612. (defun remake-lineOffsets ()
  613.   (let* ((nLines (tc:numLines))
  614.          (lineOffsets (NewHandleClear (* (c:sizeof 'short) (1+ nLines)))))
  615.     (if (not (zerop (MemError)))
  616.         (MemError)
  617.       (HLock lineOffsets)
  618.       (encode-internal (deref lineOffsets) (* nLines (c:sizeof 'short))
  619.                        'short (- (hex-string-to-int "7fff") nLines))
  620.       (HUnlock lineOffsets)
  621.       ;;; When do we know to dispose of the old lineOffsets?
  622.       (setf-tc:lineOffsets lineOffsets)
  623.       noErr)))
  624.         
  625. ; -----------------------------------------------------------------------
  626. ; -----------------------------------------------------------------------
  627. ;
  628. ; Failed Find In Next File --- THINK sends the Failed Find In Next File event to tell the 
  629. ;                              editor that its last FINF request has failed.
  630. ; 
  631. ; Event Class:    'KAHL'
  632. ; Event ID:        'NONF'
  633. ; Parameters:        none
  634.  
  635. (AEInstallEventHandler "KAHL" "NONF" 'tc:do-nonf-event 0 0)
  636.  
  637. (defun tc:do-nonf-event (event reply refCon)
  638.   (if tc:debug-trace (DebugStr "Emacs TPM code got NONF event"))
  639.   (condition-case errmsg
  640.       (progn
  641.         (beep)
  642.         (message "No more instances found")
  643.         noErr)
  644.     (error (if tc:debug-failures (DebugStr "Couldn't complete NONF"))
  645.            errAEEventNotHandled)))
  646.  
  647. ; -----------------------------------------------------------------------
  648. ; -----------------------------------------------------------------------
  649. ;
  650. ; OpenProject
  651. ;     
  652. ;     THINK sends the OpenProject event to notify the editor that a project has just been
  653. ;     opened and/or closed.  (The direct parameter gives the details.)  
  654. ;     
  655. ;     If a project was closed, the user should be asked what to do with any open
  656. ;     sourcefiles that are related to the project:  save and close, discard changes and
  657. ;     close, or leave them open.  If some of the project's sourcefiles were indeed open,
  658. ;     the user should also be advised to perform a Use Disk the next time he opens the 
  659. ;     project.
  660. ;     
  661. ;     If a project was opened, and the editor already has one of the project's sourcefiles 
  662. ;     open, it may need to read in the file's marker data now.  If so, and the file has 
  663. ;     already been modified, the marker data will be out of sync;  the best we can do is 
  664. ;     revert to the previous saved version.
  665. ;     
  666. ;     See the MiniEdit code for an example of how to handle this event.
  667. ; 
  668. ; Event Class:    'KAHL'
  669. ; Event ID:        'OPRJ'
  670. ; Parameters:
  671. ; 
  672. ;     keyDirectObject (typeShortInteger, required)
  673. ;         0 == no change (you should never get this)
  674. ;         1 == a project was opened
  675. ;         2 == a project was closed
  676. ;         3 == a project was closed, then a project was opened
  677.  
  678. (AEInstallEventHandler "KAHL" "OPRJ" 'tc:do-oprj-event 0 0)
  679.  
  680. (defun tc:do-oprj-event (event reply refCon)
  681.   (if tc:debug-trace (DebugStr "Emacs TPM code got OPRJ event"))
  682.   errAEEventNotHandled)
  683.     
  684. ; -----------------------------------------------------------------------
  685. ; -----------------------------------------------------------------------
  686. ;
  687. ; CloseProject
  688. ;     
  689. ;     THINK sends the CloseProject event to notify the editor that the current project is
  690. ;     being closed.  The keyDirectObject parameter indicates whether the related sourcefiles
  691. ;     should be saved and closed (kAEYes) or closed but not saved (kAENo).  If the direct
  692. ;     object is kAEAsk, the user should be asked what to do with any open sourcefiles (an
  693. ;     option should be provided to cancel the project close, also.)
  694. ;     The editor can decide whether to complete or abort THINK's 
  695. ;     Close Project command by sending (or failing to send) THINK a CloseProject event in
  696. ;     reply.  See the MiniEdit code for an example of how to handle this event.
  697. ; 
  698. ; Event Class:    'KAHL'
  699. ; Event ID:        'CPRJ'
  700. ; Parameters:
  701. ; 
  702. ;     keyDirectObject (typeEnumerated, required)
  703. ;         kAEYes == save and close related sourcefiles;
  704. ;         kAENo  == close related sourcefiles, discarding changes;
  705. ;         kAEAsk == ask user what to do with related sourcefiles.
  706.  
  707. (AEInstallEventHandler "KAHL" "CPRJ" 'tc:do-cprj-event 0 0)
  708.  
  709. (defun tc:do-cprj-event (event reply refCon)
  710.   (if tc:debug-trace (DebugStr "Emacs TPM code got CPRJ event"))
  711.   (condition-case errmsg
  712.       (catch 'panic
  713.         (let* ((returnedType (make-string 4 0))
  714.                (actualSize (make-string 4 0))
  715.                (yes-no-ask (make-string 4 0)))
  716.           (throw-err (AEGetParamPtr event keyDirectObject typeLongInteger returnedType
  717.                                     yes-no-ask (c:sizeof 'long) actualSize))
  718.           
  719.             ;;; For now, we simply return noErr, which allows Think to close the
  720.             ;;; project without waiting for a CPRJ event from Emacs.
  721.           
  722.           noErr))
  723.     (error (if tc:debug-failures (DebugStr "Couldn't complete CPRJ"))
  724.            errAEEventNotHandled)))
  725.